Shareware Grab Bag/Shareware Grab Bag.iso/007/tsr21src.arc/RELEASE.PAS

Pascal/Delphi Source File | 1986-07-20 | 22KB | 631 lines

{**************************************************************************
*   Releases memory above the last MARK call made.                        *
*   Copyright (c) 1986 Kim Kokkonen, TurboPower Software.                 *
*   Released to the public domain for personal, non-commercial use only.  *
***************************************************************************
*   Version 1.0 2/8/86                                                    *
*     original public release.                                            *
*     (thanks to Neil Rubenking for an outline of the method used)        *
*   Version 1.1 2/11/86                                                   *
*     fixed problem with processes which deallocate their environment.    *
*   Version 1.2 2/13/86                                                   *
*     fixed another problem with processes which deallocate environment.  *
*   Version 1.3 2/15/86                                                   *
*     added support for "named" marks.                                    *
*   Version 1.4 2/23/86                                                   *
*     added support for releasing programs which use Expanded Memory.     *
*   Version 1.5 2/28/86                                                   *
*     added more bulletproof method of finding first allocation block.    *
*   Version 1.6 3/20/86                                                   *
*     restore all FF interrupts.                                          *
*     restore the termination address to the local process.               *
*     reduce number of EMS blocks to 32.                                  *
*     fix bug in number of EMS handles in EMS release step.               *
*     restore a mysterious address in the PSP which allows RELEASE of a   *
*       COMMAND shell (emulates the EXIT command).                        *
*   Version 1.7 (date not recorded)                                       *
*     add "protected" marks.                                              *
*   Version 1.8 4/21/86                                                   *
*     fix problem when mark is installed as 'MARK '.                      *
*   Version 1.9 5/22/86                                                   *
*     release the environment of MARK when it is not contiguous with      *
*       the MARK itself.                                                  *
*     capture RELEASE calls from within batch files and don't release the *
*       batch control block.                                              *
*     fiddle with different methods of restoring interrupt vectors in     *
*       an attempt to successfully remove DoubleDos. No success, not      *
*       implemented. Note, after more effort: DDos apparently             *
*       reprograms the 8259 as well as patching the operating system.     *
*   Version 2.0 6/17/86                                                   *
*     support "file" marks placed by the new program FMARK.               *
*   Version 2.1 7/18/86                                                   *
*     fix bug in restoring "parent" address in RELEASE PSP.               *
*                                                                         *
***************************************************************************
*   telephone: [phone], CompuServe: 72457,2131.                      *
*   requires Turbo version 3 to compile.                                  *
*   Compile with mAx dynamic memory = FFFF.                               *
***************************************************************************}

{$P128}
{$C-}

program ReleaseTSR;
  {-release system memory above the last mark call}
  {-release expanded memory blocks allocated since the last mark call}

const
  Version = '2.1';
  ProtectChar = '!';          {marks whose name begins with this will be
                              released ONLY if an exact name match occurs}
  MaxBlocks = 128;            {max number of DOS allocation blocks supported}
  MaxHandles = 32;            {max number of EMS allocation blocks supported}
  EMSinterrupt = $67;         {the vector used by the expanded memory manager}

  markID = 'MARK PARAMETER BLOCK FOLLOWS'; {marking string for TSR MARK}
  fmarkID = 'FMARK TSR'; {marking string for TSR FMARK}

  {offsets into resident copy of MARK.COM for data storage}
  markOffset = $103;          {where markID is found in MARK TSR}
  fmarkOffset = $60;          {where fmarkID is found in FMARK TSR}
  vectorOffset = $120;        {where vector table is stored}
  EMScntOffset = $520;        {where count of EMS active pages is stored}
  EMSmapOffset = $522;        {where the page map is stored}

  debug = false;              {set true for detailed output report}

type
  registers =
  record case Integer of
    1 : (ax, bx, cx, dx, bp, si, di, ds, es, flags : Integer);
    2 : (al, ah, bl, bh, cl, ch, dl, dh : Byte);
  end;

  HandlePageRecord =
  record
    handle : Integer;
    numpages : Integer;
  end;

  PageArray = array[1..MaxHandles] of HandlePageRecord;
  PageArrayPtr = ^PageArray;

  Block =
  record                      {store info about each memory block}
    mcb : Integer;
    psp : Integer;
    releaseIt : Boolean;
  end;

  BlockType = 0..MaxBlocks;
  BlockArray = array[BlockType] of Block;
  AllStrings = string[255];
  HexString = string[4];

var
  Blocks : BlockArray;
  bottomBlock, blockNum : BlockType;
  markName : AllStrings;
  Regs : registers;
  FilMarkHandles, ReturnCode, StartMCB, StoredHandles, EMShandles : Integer;
  FilMarkPageMap, Map, StoredMap : PageArrayPtr;
  TrappedBytes : Real;
  MemMark, FilMark : Boolean;
  Vectors : array[0..1023] of Byte;

  procedure FindTheBlocks;
    {-scan memory for the allocated memory blocks}
  const
    MidBlockID = $4D;         {byte DOS uses to identify part of MCB chain}
    EndBlockID = $5A;         {byte DOS uses to identify last block of MCB chain}
  var
    mcbSeg : Integer;         {segment address of current MCB}
    nextSeg : Integer;        {computed segment address for the next MCB}
    gotFirst : Boolean;       {true after first MCB is found}
    gotLast : Boolean;        {true after last MCB is found}
    idbyte : Byte;            {byte that DOS uses to identify an MCB}

    function GetStartMCB : Integer;
      {-return the first MCB segment}
    begin
      Regs.ah := $52;
      MsDos(Regs);
      GetStartMCB := MemW[Regs.es:(Regs.bx-2)];
    end {getstartmcb} ;

    procedure StoreTheBlock(var mcbSeg, nextSeg : Integer;
                            var gotFirst, gotLast : Boolean);
      {-store information regarding the memory block}
    var
      nextID : Byte;
      pspAdd : Integer;       {segment address of the current PSP}
      mcbLen : Integer;       {size of the current memory block in paragraphs}

    begin

      mcbLen := MemW[mcbSeg:3]; {size of the MCB in paragraphs}
      nextSeg := Succ(mcbSeg+mcbLen); {where the next MCB should be}
      pspAdd := MemW[mcbSeg:1]; {address of program segment prefix for MCB}
      nextID := Mem[nextSeg:0];

      if gotLast or (nextID = EndBlockID) or (nextID = MidBlockID) then begin
        blockNum := Succ(blockNum);
        gotFirst := True;
        with Blocks[blockNum] do begin
          mcb := mcbSeg;
          psp := pspAdd;
        end;
      end;

    end {storetheblock} ;

  begin

    {initialize}
    StartMCB := GetStartMCB;
    mcbSeg := StartMCB;
    gotFirst := False;
    gotLast := False;
    blockNum := 0;

    {scan all memory until the last block is found}
    repeat
      idbyte := Mem[mcbSeg:0];
      if idbyte = MidBlockID then begin
        StoreTheBlock(mcbSeg, nextSeg, gotFirst, gotLast);
        if gotFirst then mcbSeg := nextSeg else mcbSeg := Succ(mcbSeg);
      end else if gotFirst and (idbyte = EndBlockID) then begin
        gotLast := True;
        StoreTheBlock(mcbSeg, nextSeg, gotFirst, gotLast);
      end else begin
        {start block was invalid}
        WriteLn('Corrupted allocation chain or program error....');
        Halt(1);
      end;
    until gotLast;

  end {findtheblocks} ;

  function StUpcase(s : AllStrings) : AllStrings;
    {-return the uppercase string}
  var
    i : Byte;

  begin
    for i := 1 to Length(s) do
      s[i] := UpCase(s[i]);
    StUpcase := s;
  end {stupcase} ;

  function FindMark(markName : AllStrings) : Integer;
    {-find the last memory block matching idstring at offset idoffset}
  var
    b : BlockType;

    function HasIDstring(segment : Integer;
                         idString : AllStrings;
                         idOffset : Integer) : Boolean;
      {-return true if idstring is found at segment:idoffset}
    var
      tString : AllStrings;
      len : Byte;

    begin
      len := Length(idString);
      tString[0] := Chr(len);
      Move(Mem[segment:idOffset], tString[1], len);
      HasIDstring := (tString = idString);
    end {HasIDstring} ;

    function GetMarkName(segment : Integer) : AllStrings;
      {-return a cleaned up mark name from the segment's PSP}
    var
      tString : AllStrings;
      tlen : Byte absolute tString;

    begin
      Move(Mem[segment:$80], tString[0], 128);
      while (tlen > 0) and ((tString[1] = ' ') or (tString[1] = ^I)) do
        Delete(tString, 1, 1);
      while (tlen > 0) and ((tString[tlen] = ' ') or (tString[tlen] = ^I)) do
        tlen := Pred(tlen);
      GetMarkName := StUpcase(tString);
    end;                      {GetMarkName}

    function MatchMemMark(segment : Integer;
                          markName : AllStrings;
                          var b : BlockType) : Boolean;
      {-return true if MemMark is unnamed or matches current name}
    var
      tString : AllStrings;
      FoundIt : Boolean;

    begin
      {check the mark name stored in the PSP of the mark block}
      tString := GetMarkName(segment);
      if (markName <> '') then begin
        FoundIt := (tString = StUpcase(markName));
        if not(FoundIt) then
          if (tString <> '') and (tString[1] = ProtectChar) then
            {current mark is protected, stop searching}
            b := 1;
      end else if (tString <> '') and (tString[1] = ProtectChar) then begin
        {stored mark name is protected}
        FoundIt := False;
        {stop checking}
        b := 1;
      end else
        {match any mark}
        FoundIt := True;
      if not(FoundIt) then
        b := Pred(b);
      MatchMemMark := FoundIt;
    end {MatchMemMark} ;

    function MatchFilMark(segment : Integer;
                          markName : AllStrings;
                          var b : BlockType) : Boolean;
      {-return true if FilMark is unnamed or matches current name}
    var
      tString : AllStrings;
      FoundIt : Boolean;

      function ExistFile(path : AllStrings) : Boolean;
        {-return true if file exists}
      var
        f : file;

      begin
        Assign(f, path);
        {$I-}
        Reset(f);
        {$I+}
        ExistFile := (IOResult = 0);
        Close(f);
      end;                    {existfile}

    begin
      {check the mark name stored in the PSP of the mark block}
      tString := GetMarkName(segment);
      if (markName <> '') then begin
        markName := StUpcase(markName);
        FoundIt := (tString = markName);
        if FoundIt then begin
          {Assure named file exists}
          WriteLn('finding mark file: ', markName);
          FoundIt := ExistFile(markName);
          if not(FoundIt) then
            {stop checking}
            b := 1;
        end;
      end else
        {file marks must be named on RELEASE command line}
        FoundIt := False;
      if not(FoundIt) then
        b := Pred(b);
      MatchFilMark := FoundIt;
    end {MatchFilMark} ;

  begin
    {scan from the last block down to find the last MARK TSR}
    b := blockNum;
    MemMark := False;
    FilMark := False;
    repeat
      if blocks[b].psp=cseg then
        {assure this program's command line is not matched}
        b:=pred(b)
      else if HasIDstring(Blocks[b].psp, markid, markOffset) then
        {an in-memory mark}
        MemMark := MatchMemMark(Blocks[b].psp, markName, b)
      else if hasidstring(blocks[b].psp, fmarkid, fmarkoffset) then
        {a file mark}
        FilMark := MatchFilMark(Blocks[b].psp, markName, b)
      else
        {not a mark}
        b:=pred(b);
    until (b < 1) or MemMark or FilMark;
    if not(MemMark or FilMark) then begin
      WriteLn('No matching marker found, or protected marker encountered.');
      Halt(1);
    end;
    FindMark := b;
  end {findmark} ;

  function Hex(i : Integer) : HexString;
    {-return hex representation of integer}
  const
    hc : array[0..15] of Char = '0123456789ABCDEF';
  var
    l, h : Byte;

  begin
    l := Lo(i); h := Hi(i);
    Hex := hc[h shr 4]+hc[h and $F]+hc[l shr 4]+hc[l and $F];
  end {hex} ;

  procedure ReadMarkFile(markName : AllStrings);
    {-read the mark file info into memory}
  var
    f : file;

  begin
    Assign(f, markName);
    Reset(f, 1);
    {read the vector table from the mark file, into a temporary memory area}
    BlockRead(f, Vectors, 1024);
    {read the number of handles stored}
    BlockRead(f, FilMarkHandles, 2);
    {get a page map area and read the page map into it}
    GetMem(FilMarkPageMap, 4*FilMarkHandles);
    BlockRead(f, FilMarkPageMap^, 4*FilMarkHandles);
    Close(f);
    {delete the mark file so it causes no mischief later}
    Erase(f);
  end {ReadMarkFile} ;

  procedure CopyVectors(bottomBlock : BlockType; vectorOffset : Integer);
    {-put interrupt vectors back into table}

  begin
    {interrupts off}
    inline($FA);
    {restore the main interrupt vector table}
    if FilMark then
      Move(Vectors, Mem[0:0], 1024)
    else
      Move(Mem[Blocks[bottomBlock].psp:vectorOffset], Mem[0:0], 1024);
    {move the old termination/break/error addresses into this program}
    Move(Mem[0:$88], Mem[CSeg:$0A], 12);
    {restore the "parent address" used by the DOS EXIT command to remove a shell}
    Move(Mem[CSeg:$0C], Mem[CSeg:$16], 2);
    {interrupts on}
    inline($FB);
  end {CopyVectors} ;

  procedure MarkBlocks(bottomBlock : BlockType);
    {-mark those blocks to be released}
  var
    b, t : BlockType;
    commandPsp, markPsp : Integer;
    ch:char;

    function cardinal(i : Integer) : Real;
      {-return "unsigned integer" in range 0..65535}
    var
      r : Real;

    begin
      r := i;
      if r < 0.0 then r := r+65536.0;
      cardinal := r;
    end {cardinal} ;

  begin

    commandPsp := Blocks[2].psp;
    markPsp := Blocks[bottomBlock].psp;

    for b := 1 to blockNum do with Blocks[b] do begin

      if (b < bottomBlock) then
        {release any trapped environment block}
        releaseIt := (psp<> cseg) and (cardinal(psp) >= cardinal(markPsp))
      else begin
        {release all but RELEASE itself and any blocks owned by COMMAND.COM}
        releaseIt := (psp <> CSeg) and (psp <> commandPsp);

        if (psp = commandPsp) then begin
          {warn about the trapping effect of batch files}
          WriteLn('Memory space for TSRs installed prior to batch file');
          WriteLn('will not be released until batch file completes.');
          WriteLn;
          ReturnCode := 1;
          {compute number of bytes temporarily trapped}
          TrappedBytes := 0.0;
          for t := 1 to b do
            if Blocks[t].releaseIt then
              TrappedBytes := TrappedBytes+16.0*cardinal(MemW[Blocks[t].mcb:3]);
        end;
      end;
    end;

    if debug then
      for b := 1 to blockNum do with Blocks[b] do
        WriteLn(b:3, ' ', Hex(psp), ' ', Hex(mcb), ' ', releaseIt);

  end {MarkBlocks} ;

  procedure ReleaseMem;
    {release DOS memory marked for release}
  var
    b : BlockType;

  begin
    with Regs do
      for b := 1 to blockNum do with Blocks[b] do
        if releaseIt then begin
          ah := $49;
          {the block is always 1 paragraph above the MCB}
          es := Succ(mcb);
          MsDos(Regs);
          if Odd(flags) then begin
            WriteLn('Could not release block at segment ', Hex(es));
            WriteLn('Memory is now a mess... Please reboot');
            Halt(1);
          end;
        end;
  end {releasemem} ;

  function EMSpresent : Boolean;
    {-return true if EMS memory manager is present}
  var
    f : file;

  begin
    {"file handle" defined by the expanded memory manager at installation}
    Assign(f, 'EMMXXXX0');
    {$I-}
    Reset(f);
    {$I+}
    EMSpresent := (IOResult = 0);
    Close(f);
  end {EMSpresent} ;

  procedure RestoreEMSmap;
    {-restore EMS to state at time of mark}

    function EMShandlesActive : Integer;
      {-return the number of active EMS handles}

    begin
      Regs.ah := $4B;
      Intr(EMSinterrupt, Regs);
      if Regs.ah <> 0 then begin
        WriteLn('EMS device not responding');
        EMShandlesActive := 0;
        Exit;
      end;
      EMShandlesActive := Regs.bx;
    end {EMShandlesActive} ;

    function GetHandles(bottomBlock : BlockType; EMScntOffset : Integer) : Integer;
      {-return the number of handles stored by mark}
    var
      gh : Integer;

    begin
      if FilMark then
        GetHandles := FilMarkHandles
      else begin
        Move(Mem[Blocks[bottomBlock].psp:EMScntOffset], gh, 2);
        GetHandles := gh;
      end;
    end {gethandles} ;

    function getstoredmap(bottomBlock : BlockType; EMSmapOffset : Integer) : PageArrayPtr;
      {-returns a pointer to the stored page array}

    begin
      if FilMark then
        getstoredmap := FilMarkPageMap
      else
        getstoredmap := Ptr(Blocks[bottomBlock].psp, EMSmapOffset);
    end {GetStoredMap} ;

    procedure EMSpageMap(var PageMap : PageArray);
      {-return an array of the allocated memory blocks}

    begin
      Regs.ah := $4D;
      Regs.es := Seg(PageMap);
      Regs.di := Ofs(PageMap);
      Regs.bx := 0;
      Intr(EMSinterrupt, Regs);
      if Regs.ah <> 0 then
        WriteLn('EMS device not responding');
    end {EMSpageMap} ;

    procedure ReleaseEMSblocks(var oldmap, newmap : PageArray);
      {-release those EMS blocks allocated since MARK was installed}
    var
      o, n, nhandle : Integer;

      procedure EMSdeallocate(EMShandle : Integer);
        {-release the allocated expanded memory}

      begin
        Regs.ah := $45;
        Regs.dx := EMShandle;
        Intr(EMSinterrupt, Regs);
        if Regs.ah <> 0 then begin
          WriteLn('Program error or EMS device not responding');
          WriteLn('EMS memory is now a mess... Please reboot');
          Halt(1);
        end;
      end;                    {EMSdeallocate}

    begin
      for n := 1 to EMShandles do begin
        {scan all current handles}
        nhandle := newmap[n].handle;
        if StoredHandles > 0 then begin
          {see if current handle matches one stored by MARK}
          o := 1;
          while (oldmap[o].handle <> nhandle) and (o <= StoredHandles) do
            o := Succ(o);
          {if not, deallocate the current handle}
          if (o > StoredHandles) then
            EMSdeallocate(nhandle);
        end else
          {no handles stored by MARK, deallocate all current handles}
          EMSdeallocate(nhandle);
      end;
    end {releaseEMSblocks} ;

  begin
    {see how many EMS handles are currently active}
    EMShandles := EMShandlesActive;
    if EMShandles > MaxHandles then
      WriteLn('EMS process count exceeds capacity of RELEASE - no action taken')
    else if EMShandles <> 0 then begin
      {see how many handles were active when MARK was installed}
      StoredHandles := GetHandles(bottomBlock, EMScntOffset);
      {get the existing EMS page map}
      GetMem(Map, 4*EMShandles);
      EMSpageMap(Map^);
      {get the stored page map}
      StoredMap := getstoredmap(bottomBlock, EMSmapOffset);
      {compare the two maps and deallocate pages not in the stored map}
      ReleaseEMSblocks(StoredMap^, Map^);
    end;
  end;

begin

  WriteLn;
  ReturnCode := 0;

  {see if a particular mark is named}
  if ParamCount > 0 then
    markName := ParamStr(1)
  else
    markName := '';

  {get all allocated memory blocks in normal memory}
  FindTheBlocks;

  {find the last one marked with the MARK idstring, and MarkName if specified}
  bottomBlock := FindMark(markName);

  {mark those blocks to be released}
  MarkBlocks(bottomBlock);

  {get file mark information into memory}
  if FilMark then
    ReadMarkFile(markName);

  {copy the vector table from the MARK copy}
  CopyVectors(bottomBlock, vectorOffset);

  {release normal memory marked for release}
  ReleaseMem;

  {deal with expanded memory}
  if EMSpresent then
    RestoreEMSmap;

  {DOS will release this program's memory when it exits}
  {write success message}
  Write('RELEASE ', Version, ' - Memory released above last MARK ');
  if markName <> '' then
    WriteLn('(', StUpcase(markName), ')')
  else
    WriteLn;

  if ReturnCode <> 0 then
    WriteLn(TrappedBytes:0:0, ' bytes temporarily trapped until batch file completes');

  Halt(ReturnCode);
end.